home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / HANDLES.SEQ < prev    next >
Text File  |  1988-07-18  |  9KB  |  276 lines
  1. \ HANDLES.SEQ   Handle impementation file               by Tom Zimmer
  2.  
  3. \ Link this file into the FILELIST chain.
  4.  
  5. FILES DEFINITIONS
  6.  
  7. VARIABLE HANDLES.SEQ
  8.  
  9. FORTH DEFINITIONS
  10.  
  11. \ This file contains the code to talk to a file with the
  12. \ DOS 2.00+ handle routines.
  13.  
  14. DECIMAL
  15.  
  16. 70 CONSTANT B/HCB  68 CONSTANT HNDLOFFSET
  17. VARIABLE RWERR
  18.  
  19.                 \ Attrib is normally  zero (0) for Read/Write.
  20.                 \ Attrib may be set to one (1) for Write ONLY.
  21.                 \ Attrib may be set to two (2) for Read  ONLY.
  22. : >ATTRIB       ( handle --- attrib-addr )      66 + ;
  23.  
  24. : >HNDLE        ( handle --- handle-addr )      HNDLOFFSET + ;
  25. : >NAM          ( handle --- name-string-addr ) 1+   ;
  26. : CLR-HCB       ( HANDLE - ) DUP B/HCB ERASE -1 SWAP >HNDLE ! ;
  27.  
  28.                 \  defining    running
  29. : HANDLE        ( name ---  |  --- addr )
  30.                  CREATE HERE B/HCB ALLOT CLR-HCB ;
  31.  
  32.         \       The HANDLE memory data structure is as shown here.
  33.  
  34.         \         1byte    65 bytes      2 bytes    2 bytes
  35.         \       [ count  ] [ name....0 ] [ attrib ] [ handle > -1 ]
  36.         \         addr       addr+1        addr+66    addr+68
  37.         \          |          |             |          |
  38.         \          |          |_>NAM        |_>ATTRIB  |_>HNDLE
  39.         \          |
  40.         \          |_Address of the array returned by a word
  41.         \            defined with HANDLE.
  42.  
  43. CREATE DEFEXT 3 C,-T ASCII S C,-T ASCII E C,-T ASCII Q C,-T 4 ALLOT
  44.  
  45. : ?DEF.EXT      ( handle --- )    \ maybe add an extension to file
  46.                  dup c@ 60 > if drop exit then
  47.                  >r true r@ count bounds
  48.                ?do      i c@ ascii . =
  49.                         if      drop false leave
  50.                         then
  51.                 loop      \ returns true if no decimal point found
  52.                 if      defext c@
  53.                         if      defext count r@ count + 1+ swap cmove
  54.                                 ascii . r@ count + c!
  55.                                 defext c@ 1+ r@ c@ + r@ c!
  56.                         then
  57.                 then    r>drop ;
  58.  
  59. : $>HANDLE       ( a1 a2 --- )
  60.                  dup>r CLR-HCB
  61.                  count 64 min dup r@ c! r@ 1+ swap
  62.                  0 max cmove 0 r@ count + c!
  63.                  r> ?DEF.EXT ;
  64.  
  65. : !HCB          ( handle --- )
  66.                  BL WORD CAPS @
  67.                  IF      DUP COUNT UPPER
  68.                  THEN    SWAP $>HANDLE ;
  69.  
  70. : FCB>HANDLE    ( A1 A2 --- )
  71.                 DUP CLR-HCB
  72.                 1+ dup>r SWAP 1+ dup>r 8 OVER + SWAP
  73.                 DO      I C@ BL = ?LEAVE
  74.                         I C@ OVER C! 1+
  75.                 LOOP    ASCII . OVER C! 1+
  76.                 R> 8 + 3 OVER + SWAP
  77.                 DO      I C@ BL = ?LEAVE
  78.                         I C@ OVER C! 1+
  79.                 LOOP    0 OVER C! R@ - R> 1- C! ;
  80.  
  81. : HANDLE>EXT    ( handle -- a1 )
  82.                 count + dup dup 4 -
  83.                 do      i c@ ascii . =
  84.                         if      drop i leave  then
  85.                 loop    ; \ points to final decimal point if present
  86.  
  87. : $>EXT         ( string-extension handle --- )
  88.                 dup c@ 60 > if 2drop exit then
  89.                 dup>r handle>ext
  90.                 ascii . over c! 1+ >r count r@
  91.                 swap cmove r> 3 + 0 over c! r@ - 1- r> c! ;
  92.  
  93. CODE HDOS1      ( cx dx fun -- ax cf | error-code 1 )
  94.                 pop ax
  95.                 pop dx
  96.                 pop cx
  97.                 int $21
  98.                 push ax
  99.              u< if
  100.                 mov al, # 1
  101.              else
  102.                 mov al, # 0
  103.              then
  104.                 sub ah, ah
  105.                 1push
  106.                 end-code
  107.  
  108. CODE HDOS3      ( bx cx dx ds fun -- ax cf | error-code 1 )
  109.                 pop ax
  110.                 pop ds
  111.                 pop dx
  112.                 pop cx
  113.                 pop bx
  114.                 int $21
  115.                 push ax
  116.              u< if
  117.                 mov al, # 1
  118.              else
  119.                 mov al, # 0
  120.              then
  121.                 sub ah, ah
  122.                 push ax
  123.                 mov ax, cs
  124.                 mov ds, ax
  125.                 next
  126.                 end-code
  127.  
  128. CODE HDOS4      ( bx cx dx fun -- ax cf | error-code 1 )
  129.                 pop ax
  130.                 pop dx
  131.                 pop cx
  132.                 pop bx
  133.                 int $21
  134.                 push ax
  135.              u< if
  136.                 mov al, # 1
  137.              else
  138.                 mov al, # 0
  139.              then
  140.                 sub ah, ah
  141.                 1push
  142.                 end-code
  143.  
  144. CODE MOVEPOINTER ( double-offset handle --- )
  145.                 pop bx
  146.                 ADD bx, # HNDLOFFSET
  147.                 mov ax, 0 [bx]
  148.                 mov bx, ax
  149.                 pop cx
  150.                 pop dx
  151.                 mov ax, # $4200  \ from start of file
  152.                 int $21
  153.                 next
  154.                 end-code
  155.  
  156. CODE ENDFILE    ( handle --- double-end )
  157.                 pop bx
  158.                 add bx, # hndloffset
  159.                 mov ax, 0 [bx]
  160.                 mov bx, ax
  161.                 mov cx, # 0
  162.                 mov dx, # 0
  163.                 mov ax, # $4202  \ from end of file
  164.                 int $21
  165.              u< if
  166.                 sub ax, ax
  167.              then
  168.                 push ax
  169.                 push dx
  170.                 next
  171.                 end-code
  172.  
  173. DEFER PATHSET   ( handle --- f1 )
  174.  
  175. ' 0= IS PATHSET
  176.  
  177. \   Code loaded later is plugged into PATHSET, to prepend the
  178. \ current path to the handle specified on the top of the stack.
  179. \
  180. \   The returned vlue is zero if the path was set properly, or
  181. \ non-zero if an error occured while setting the path.
  182.  
  183. CODE <HRENAME>  ( handle1 handle2 --- ax cf=0 | error-code 1 )
  184.                 pop bx
  185.                 add bx, # 1
  186.                 mov di, bx
  187.                 pop bx
  188.                 push es         \ Save ES for later restoral
  189.                 mov ax, ds
  190.                 mov es, ax      \ set es to ds
  191.                 add bx, # 1
  192.                 mov dx, bx
  193.                 mov ax, # $5600  \ from start of file
  194.                 int $21
  195.                 pop es          \ Restore ES
  196.                 push ax
  197.              u< if
  198.                 mov al, # 1
  199.              else
  200.                 mov al, # 0
  201.              then
  202.                 sub ah, ah
  203.                 1push
  204.                 end-code
  205.                         \ returns 18 if the rename was good, not zero.
  206.  
  207. : HRENAME       ( HANDLE1 HANDLE2 --- RETURN-CODE )
  208.                 DUP PATHSET DROP OVER PATHSET DROP
  209.                 <HRENAME>
  210.                 if      $0FF and
  211.                 else    drop 0
  212.                 then    ;
  213.  
  214. : HCREATE       ( handle --- error-code )
  215.                 DUP PATHSET ?dup if  swap drop exit then
  216.                 dup >hndle >r       \     save handle address
  217.                 dup >attrib @         \   hndl --- bx hndl attib
  218.                 swap >nam               \ --- bx attrib name
  219.                 $3C02 hdos1 0=
  220.                 if      r@ ! 0      \ stuff handle, ret 0
  221.                 else    $0FF and
  222.                 then    r>drop ;
  223.  
  224. VARIABLE RWMODE 2 RWMODE !-T    \ default to read/write
  225.  
  226. : HOPEN         ( handle --- error-code )
  227.                 DUP PATHSET ?dup if  nip exit then
  228.                 dup >hndle >r   \           save handle address
  229.                 dup >attrib @     \         hndl --- hndl attib
  230.                 swap >nam           \       --- attrib name
  231.                 $3D00 rwmode @ or      \
  232.                 hdos1 0=                \   read/write attribs
  233.                 if      r@ ! 0            \ stuff handle, ret 0
  234.                 else    $0FF and             \ else error code
  235.                 then    r>drop ;             \ clean rstack
  236.  
  237. : HCLOSE        ( handle --- return-code )
  238.                 >hndle dup @ -1 rot ! dup -1 >
  239.                 if      0 0 $3E00 hdos4
  240.                         if      $0FF and
  241.                         else    drop 0 then
  242.                 else    drop 0
  243.                 then    ;
  244.  
  245. : HDELETE       ( handle --- return-code )
  246.                 0 0 rot >nam $4100 hdos4
  247.                 if $0FF and else drop 0 then ;
  248.  
  249.                 \ extended read
  250. : EXHREAD       ( a1 n1 handle segment -- length-read )
  251.                 >r >hndle @ -rot swap r> $3F00 hdos3
  252.                 if      $0FF and rwerr ! 0 then ;
  253.  
  254.                 \ extended write
  255. : EXHWRITE      ( a1 n1 handle segment -- length-written )
  256.                 >r >hndle @ -rot swap r> $4000 hdos3
  257.                 if      $0FF and rwerr ! 0 then ;
  258.  
  259. : HWRITE        ( a1 n1 handle --- length-written )
  260.                 >hndle @ -rot swap    \ handle count addr
  261.                 $4000 hdos4 if   $0FF and rwerr ! 0 then ;
  262.  
  263. : HREAD         ( a1 n1 handle --- length-read )
  264.                 >hndle @ -rot swap    \ handle count addr
  265.                 $3F00 hdos4 if   $0FF and rwerr ! 0 then ;
  266.  
  267. : FINDFIRST     ( string --- f1 )
  268.                 $010 swap $4E00 hdos1 drop $0FF and ;
  269.  
  270. : FINDNEXT      ( --- f1 )
  271.                 $000  $000 $4F00 hdos1 drop $0FF and ;
  272.  
  273. : SET-DTA       ( A1 --- )
  274.                 $1A BDOS DROP ;
  275.  
  276.